home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / textio.arc / TEXTIO.PAS < prev   
Pascal/Delphi Source File  |  1991-04-28  |  10KB  |  388 lines
  1. unit TextIO;
  2.  
  3. {  useful text i/o features with turbo pascal:
  4.  
  5.      1. large text buffers for speedier handling when needed
  6.      2. complete seek function for text files
  7.      3. write formatted output to a string variable
  8.      4. read contents of a string variable as formatted input
  9.      5. backup to the previous line of a file (if possible)
  10.  
  11.    language:  turbo pascal macintosh "(*MAC-  -MAC*)" comments
  12.          or:  turbo pascal 4.0 ibm.  "(*IBM-  -IBM*)" comments
  13.  
  14.    by d.g.gilbert
  15.    dogStar software
  16.    po box 302, bloomington, in 47402
  17.    compuserve  71450,1570
  18.  
  19.    Translated to a unit by Mike Babulic,  (Jan.25,1989)
  20.                            3827 Charleswood Dr. N.W.
  21.                            Calgary, Alberta, CANADA
  22.                            T2L 2C7
  23.                            compuserve: 72307,314
  24.  
  25.         NOTE:  1) This unit has been created and tested on MS/DOS only.
  26.         -----     Porting to the Macintosh will involve some modification,
  27.                   especially for new additions like "BackLn".
  28.  
  29.                2) Obviously if you do "interesting" things in your programs
  30.                   you can expect some side-effects the authors couldn't
  31.                   possibly forsee. Be careful!
  32.  
  33.  
  34.    MODIFICATION LOG
  35.    ----------------
  36.  
  37.      88/01/25 - Turned demo program into a unit. (Babulic)
  38.  
  39.      88/01/27 - BackLn procedure added. (Babulic)
  40. }
  41.  
  42.  
  43. interface
  44.  
  45. {$R-}   { Turn off range checking       }
  46. {$I-}   { Turn off I/O error checking   }
  47.  
  48. (*IBM-*)
  49.    USES  DOS;
  50.  
  51.    TYPE
  52.         chars   = PACKED ARRAY [0..maxint] OF char;
  53.         bufferPtr = ^chars;
  54.         procPtr   = pointer;
  55.  
  56.         tpFileRec = RECORD            {turbo pascal ibm text file record}
  57.           handle   : word;
  58.           mode     : word;
  59.           fBufSize : word;
  60.           private  : word;
  61.           fBufPos  : word;
  62.           fBufEnd  : word;
  63.           fBuffer  : bufferPtr;
  64.           openFunc : procptr;
  65.           inOutFunc: procptr;
  66.           flushFunc: procptr;
  67.           closeFunc: procptr;
  68.           userdata : PACKED ARRAY[1..16] OF byte;
  69.           name     : PACKED ARRAY [0..79] OF char;
  70.           tbuffer  : PACKED ARRAY [0..127] OF char; { default buffer}
  71.           END;
  72. (*-IBM*)
  73. (*MAC-
  74.    USES  memTypes, quickDraw, osIntf, toolIntf;
  75.  
  76.    TYPE
  77.       chars   = PACKED ARRAY [0..maxint] OF char;
  78.       bufferPtr = ^chars;
  79.       pointer = ^integer;
  80.  
  81.       tpFileRec   = RECORD            {turbo pascal mac file record }
  82.           fInpFlag: boolean;
  83.           fOutFlag: boolean;
  84.           fRefNum : integer;
  85.           fVrefNum: integer;
  86.           fBufSize: integer;
  87.           fBufPos : integer;
  88.           fBufEnd : integer;
  89.           fBuffer : bufferPtr;
  90.           fInOutProc: procPtr;
  91.           END;
  92. -MAC*)
  93.  
  94. CONST
  95.       forOutput = true; forInput = false;
  96.  
  97.  
  98.  
  99. FUNCTION openText( VAR f: text;
  100.          fname : STRING;
  101.          output: boolean;  {true if want a rewrite }
  102.          bufsize: integer
  103.          ): boolean;     { true if opened successfully }
  104.  
  105. PROCEDURE closeText( VAR f: text);
  106.  
  107. FUNCTION PosText(VAR f:text):LongInt;
  108.  
  109.  
  110. TYPE seekType = (seek_set, seek_cur, seek_end);
  111.  
  112. PROCEDURE seekText( VAR f: text; offset: longInt; seekFrom : seektype);
  113.   { seek for textfiles }
  114.  
  115.  
  116. procedure BackLn(var f:Text);
  117.  
  118.  
  119. PROCEDURE openStrIO( VAR f: text; VAR s: STRING; out: boolean);
  120.   { assign file input/output to string. }
  121.  
  122. PROCEDURE closeStrIO( VAR f: text; VAR s: STRING);
  123.   { close stringiO: get length }
  124.  
  125.  
  126. {==========================================================================}
  127.  
  128. implementation
  129.  
  130.  
  131. (*IBM-*)
  132. FUNCTION msDosSeek( fh:integer; index:longint; fromwhere:seekType):LongInt;
  133. { move file pointer to byte index (hiIndx,lowIndx), respective to fromWhere }
  134. TYPE  long = record lo,hi:word end;
  135. VAR  reg : registers;
  136.      l   : long;
  137. BEGIN WITH REG DO BEGIN
  138.   ah:= $42; { move f^ }
  139.   al:= ord(fromwhere);
  140.   cx:= long(index).hi; {hiindex}
  141.   dx:= long(index).lo; {lowIndex}
  142.   bx := fh;
  143.   msdos(reg);
  144.   IF 0 = (reg.flags AND $01) THEN
  145.     msdosSeek:= 0
  146.   ELSE BEGIN
  147.     l.hi:= dx;
  148.     l.lo:= ax;
  149.     msdosSeek := longint(l);
  150.   END;
  151. END  END; { msDosSeek }
  152. (*-IBM*)
  153.  
  154. {--------------------------------------------------------------------------}
  155.  
  156. FUNCTION openText( VAR f: text;
  157.          fname : STRING;
  158.          output: boolean;  {true if want a rewrite }
  159.          bufsize: integer
  160.          ): boolean;     { true if opened successfully }
  161.  
  162. VAR  abuf: pointer;
  163.      err: integer;
  164. BEGIN
  165.  
  166. (*IBM-*)
  167.     assign( f, fname);
  168.    { now change buf to the size we want}
  169.     WITH tpfilerec(f) DO BEGIN
  170.       getmem( abuf, bufsize);
  171.       fBuffer:= abuf;
  172.       fBufSize:= bufsize;
  173.       END;
  174.     IF output THEN rewrite( f) ELSE reset(f);
  175.     err:= ioresult;
  176.     IF err <> 0 THEN dispose(abuf); {forget it}
  177.     openText:= err = 0;
  178. (*-IBM*)
  179. (*MAC-
  180.     IF output THEN rewrite( f, fname, bufsize)
  181.     ELSE reset( f, fname, bufsize);
  182.     openText:= ioresult = 0;
  183. -MAC*)
  184. END; {openText}
  185.  
  186. PROCEDURE closeText( VAR f: text);
  187. VAR  abuf: pointer;
  188. BEGIN
  189. (*IBM-*)
  190.        abuf:= tpfilerec(f).fBuffer;
  191.        close(f);
  192.        dispose(abuf);
  193. (*-IBM*)
  194. END;
  195.  
  196.  
  197. FUNCTION PosText(VAR f:text):LongInt;
  198.   TYPE  long = record lo,hi:word end;
  199.   VAR  reg : registers;
  200.        p   : longint;
  201.        l   : long  ABSOLUTE p;
  202.   BEGIN
  203.     WITH REG DO BEGIN
  204.       ah:= $42; { move f^ }
  205.       al:= ord(seek_cur);
  206.       cx:= 0;
  207.       dx:= 0;
  208.       bx := tpfilerec(f).handle;
  209.       msdos(reg);
  210.       l.hi:= dx;
  211.       l.lo:= ax;
  212.     END;
  213.     WITH tpfilerec(f) DO BEGIN
  214.       IF mode=fmOutput THEN
  215.         PosText := p + fBufPos
  216.       ELSE
  217.         PosText := p - fBufEnd + fBufPos;
  218.     END
  219.   END;
  220.  
  221.  
  222. (*IBM-*)
  223. CONST strFileName = '$%#temp.tmp';
  224. CONST needStrFile: boolean = true; {1st time open tempFile }
  225. VAR   strFile    : text; {.ibm -- save file i/o information for strIO}
  226. (*-IBM*)
  227.  
  228. PROCEDURE openStrIO( VAR f: text; VAR s: STRING; out: boolean);
  229. { assign file input/output to string. }
  230. BEGIN
  231.  
  232. (*IBM-*)
  233.    IF needStrFile THEN BEGIN
  234.      assign(strFile, strFileName);
  235.      rewrite(strFile); {<< need this to fill in valid turbo proc ptrs}
  236.      tpfilerec(f):= tpfilerec(strFile);
  237.      close(strFile); erase(strFile);
  238.      tpfilerec(strfile):= tpfilerec(f);
  239.      needStrFile:= false;
  240.      END;
  241.    tpfilerec(f):= tpfilerec(strFile);
  242.    WITH tpFileRec(f) DO BEGIN
  243.      IF out THEN mode:= fmOutput ELSE mode:= fmInput;
  244.      END;
  245. (*-IBM*)
  246. (*MAC-
  247.    WITH tpfilerec(f) DO BEGIN
  248.      fInpFlag:= NOT out;
  249.      fOutFlag:= out;
  250.      fRefNum:= 1; {dummy}
  251.      fVrefNum:= 1;
  252.      fInOutProc:= NIL;
  253.      END;
  254. -MAC*)
  255.    WITH tpFileRec(f) DO BEGIN
  256.      fBuffer:= @s[1];
  257.      fBufSize:= 255; {assume it is full string}
  258.      IF out THEN fBufEnd:= fBufSize
  259.      ELSE fBufEnd:= length(s);
  260.      fBufPos:= 0;
  261.      END;
  262. END; {openStrIO}
  263.  
  264. PROCEDURE closeStrIO( VAR f: text; VAR s: STRING);
  265. { close stringiO: get length }
  266. VAR  err: integer;
  267. BEGIN
  268.    s[0]:= chr( tpFileRec(f).fBufPos);
  269. END; {closeStrIO}
  270.  
  271.  
  272.  
  273.  
  274. PROCEDURE seekText( VAR f: text; offset: longInt;
  275.             seekFrom : seektype);
  276. { seek for textfiles }
  277. VAR
  278.    count: longint;
  279.    iseek: integer;
  280.    err  : integer;
  281. (*IBM-*)
  282.    uf   : FILE;
  283. BEGIN
  284.   WITH tpFileRec(f) DO BEGIN
  285.    offset := offset + fBufPos;
  286.    IF handle<0 THEN {nada - not a disk file}
  287.    ELSE IF (seekFrom=seek_cur) and (offset>=0)
  288.            and (  (mode=fmInput) and (offset<fBufEnd)
  289.                or (mode=fmOutput) and (offset<=fBufPos)) THEN
  290.      fBufPos := offset
  291.    ELSE BEGIN
  292.     offset := offset - fBufPos;
  293.     IF mode = fmOutput THEN BEGIN
  294.      { flush buffer to disk if seek on output file}
  295.       move(f, uf, sizeof(uf));    { need right file type for blockwrite}
  296.       fileRec(uf).recsize:= 1;
  297.       blockwrite( uf, fBuffer^, fBufPos, err);
  298.       fBufPos:= 0;
  299.       END;
  300.     IF seekFrom = seek_cur THEN
  301.       offset:= offset - fBufEnd + fBufPos;
  302.     IF 0 = msdosSeek( handle, offset, seekFrom) THEN BEGIN
  303.       fBufPos:= 0; fBufEnd:= 0; {next read/write will fill buffer as needed}
  304.       END;
  305.    END;
  306.   END; {with}
  307. (*-IBM*)
  308. (*MAC-
  309. BEGIN
  310.   CASE seekFrom OF
  311.     seek_set : iseek:= fsFromStart; {offset from 0}
  312.     seek_cur : iseek:= fsFromMark;
  313.     seek_end : iseek:= fsFromLEOF;
  314.     END;
  315.   WITH tpFileRec(f) DO
  316.    IF fRefNum=0 THEN {not a disk file}
  317.    ELSE BEGIN
  318.     IF fOutFlag THEN BEGIN { flush buffer to disk if seek on output file}
  319.       count:= fBufPos;
  320.       err:= fsWrite( fRefNum, count, ptr(fBuffer));
  321.       fBufPos:= 0;
  322.       END
  323.     ELSE IF seekFrom = seek_cur THEN
  324.       offset:= offset - fBufEnd + fBufPos;
  325.     IF 0 = setFpos( fRefNum, iseek, offset) THEN BEGIN
  326.       fBufEnd:= 0; fBufPos:= 0;
  327.       END;
  328.    END;
  329. -MAC*)
  330. END; {seekText}
  331.  
  332.  
  333.  
  334. procedure BackCh(var f:Text);
  335.   var  p,q: longint;
  336.        ch: char;
  337.   begin with tpFileRec(f) do begin
  338.     if fBufPos>0 then
  339.       SeekText(f,-1,seek_cur)
  340.     else
  341.     {
  342.       if mode=fmOutput then begin
  343.         SeekText(f,-1,seek_cur);
  344.        end
  345.       else } begin
  346.         p := PosText(f) - 1;
  347.         q := p - fBufSize;
  348.         if q<0 then q := 0;
  349.         SeekText(f,q,seek_set);
  350.         read(f,ch);
  351.         SeekText(f,p-1,seek_cur);
  352.       end;
  353.   end  end;
  354.  
  355. procedure BackLn(var f:Text);
  356.   var ch: char;
  357.       p:  longint;
  358.       uf: File;
  359.   begin
  360.     BackCh(f); {Skip LF}
  361.     BackCh(f); {Skip CR}
  362.     if tpFileRec(f).mode=fmInput then begin
  363.       REPEAT
  364.         BackCh(f);
  365.       UNTIL eoln(f);
  366.       if eof(f) then
  367.         SeekText(f,0,seek_set)
  368.       else
  369.         ReadLn(f);
  370.      end
  371.     else with tpFileRec(f) do begin
  372.       reset(f);
  373.       SeekText(f,0,seek_end);
  374.       p := PosText(f);
  375.       BackLn(f);
  376.       p := PosText(f);
  377.       close(f);
  378.       append(f);
  379.       IF 0 = msdosSeek( handle,p,seek_set) THEN BEGIN
  380.         fBufPos := 0; fBufEnd := 0;
  381.         END;
  382.     end;
  383.   end;
  384.  
  385.  
  386. END.
  387.  
  388.